perm filename ALPHA.F4[XX,LCS]2 blob
sn#206559 filedate 1976-03-16 generic text, type T, neo UTF8
00100 C****** FOR LISTS OF LETTERS, ETC. AND TRILL *******
00200 SUBROUTINE ALPHA
00300 COMMON /PLTR/IPLT,RHT,DIS /FONT/JFONT
00400 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
00500 EQUIVALENCE(J3,JQ(1)),(J4,JQ(2)),(J5,JQ(3)),(R5,RJQ(3)),
00600 1(R8,RJQ(6)),(NRJ,RJQ(8)),(JX,JQ(11)),(RSX,JQ(12)),
00700 1(R6,RJQ(4)),(J7,JQ(5)),(J8,JQ(6)),(J9,JQ(7)),(J10,JQ(8))
00800 1,(J6,JQ(4)),(R7,RJQ(5)),(R4,RJQ(2)),(IFNT,JQ(13)),(J11,JQ(9)),
00900 1(RSP,JQ(15)),(RY,JQ(16)),(RX,JQ(17)),(RZ,JQ(18)),(RW
01000 1,JQ(19)),(RB,JQ(20)),(R,RJQ(20)),(FILL,RJQ(19)),(R9,RJQ(7))
01100 1,(JTR,RJQ(17)),(RF,RJQ(15)),(JR3,RJQ(14)),(R3,RJQ(1))
01200 1,(R10,RJQ(8)),(R11,RJQ(9))
01300 COMMON/STF/RSTFAC(8),RSTJ2 /POSI/STFF(8),JJ2,POS
01400 DATA R4X/-2.1/,IFNT/1/
01500
01600 IF(JA.EQ.7)GO TO 20
01700 JTR=99
01800 IF(R5.GE.100)R5=R5-100
01900 C >100 FOR TEXT IN ORCH SCORES FOR ALL SEP. PARTS.
02000 C PRIMITIVE IS DEFAULT FONT. #=SET BACK TO PRIM.
02100 C ONLY 11 LETTERS WITHOUT FONT RESET.
02200 IF(NR.EQ.'PRIM0')GO TO 54
02300 IF(NR.EQ.'BDI40')GO TO 54
02400 NR='BDR40'
02500 C THE ABOVE IN CASE FONT IS NOT ESTABLISHED.
02600 54 R=19.7*R5*RSTJ2
02700 RB=J3
02800 RW=R4
02900 J9=0
03000 C J9=0 AVOIDS ROTATION IN 'CLEFS'
03100 DO 50 KA=4,6
03200 NXZ=-1
03300 RZ=RJQ(KA)
03400 CC JY=RZ
03500 CC IF(JY.NE.RZ)GO TO 130
03600 CC IF(JY.EQ.RZ)GO TO 13
03700 C WILL LOSE ON "0AB0" IN OLD FILES**************
03800 CC IF(JY.GT.999999)GO TO 13
03900 CC130 RZ=100.*RZ
04000 C FOR OLD FORMAT OF CODE 16
04100 13 JY=RZ+.2
04200 JX=1000000
04300 DO 53 LA=1,4
04400 J5=JY/JX
04500 J5X=J5
04600 R3=J3
04700 IF(J5.EQ.99)GO TO 55
04800 73 IF(KFNT)IFNT=1
04900 C READS OLD SYS. AND NEW AUTOMATIC LWR CASE.
05000 IF(J5.LT.70)GO TO 72
05100 KFNT=-1
05200 C SETS AUTOMATIC LOWER CASE FLAG.
05300 IFNT=-1
05400 C 60 ADDED FOR LOWER CASE LETTERS.
05500 J5=J5-60
05600 C NO MORE IN THIS WD.
05700 72 IF(J5.LT.50)GO TO 1
05800 GO TO(2,3,9,4,5),J5-49
05900 C SWITCHES FOR DIFF. FONTS.(55 MAKES ')48=UPR,49=LWR,50=BDR,51=BDI,52=PRM
06000 C ********* UPPER AND LOWER NUMBERS(48,49) NO LONGER NEEDED.(SEE 73 ↑)
06100 IF(J5.GT.55)GO TO 10
06200 J5=36
06300 R4=R4+2.9
06400 C 55 WILL MAKE ' --- 56=? 57=! (THEY COME AFTER y z IN BDR46)
06500 GO TO 1
06600 10 J5=J5+6
06700 NRX=NR
06800 NXZ=0
06900 NR='BDR40'
07000 NJF=JFONT
07100 JFONT=-1
07200 GO TO 1
07300 2 NR='BDR40'
07400 C &=NON-ITALICS -- JFONT IS TEMPORARY SWITCH 5/74
07500 IF(JFONT)GO TO 9
07600 GO TO 11
07700 CC GO TO 8
07800 3 NR='BDI40'
07900 C @=51=ITALICS
08000 IF(JFONT)GO TO 9
08100 C TYPE '44 -1' TO MAKE ALL FONTS INTO 'PRIM'
08200 CC8 IF(IFNT.EQ.0)IFNT=-1
08300 GO TO 11
08400 4 FILL=-2
08500 GO TO 11
08600 5 FILL=0
08700 GO TO 11
08800 9 NR='PRIM0'
08900 GO TO 11
09000 1 CALL SPACER(J5,IFNT,RB,R)
09100 IF(J5.GT.60)GO TO 71
09200 C NOW 62=? 63=! IN BDR46
09300 IF(J5-47)7,6,11
09330 7 IF(R11.NE.0)GO TO 79
09400 IF(JFONT)78,78,77
09460 79 R9=R11
09470 J9=-1
09471 C FOR ROTATION, IF ANY.
09475 C R11=ROTATION(CLOCKWISE) IN DEGREES.
09487 GO TO 77
09500 78 IF(IPLT.GE.0)GO TO 30
09600 C JFONT=0 FOR FIXED WIDTH OF FONTS. = AND ONLY DPYS PRIMITIVE.
09700 CC J5=J6
09800 CC IF(IFNT.EQ.0)GO TO 30
09900 77 IF(J5.GE.36)GO TO 30
10000 C PUNCTUATION AND SPACE.
10100 IF(NR.NE.'PRIM0')GO TO 70
10200 IF(IFNT.GE.0)GO TO 30
10300 CC*** WAS (IFNT.EQ.1) ???? 1/76
10400 IF(J5.LT.10)GO TO 30
10500 C JUMP TO USE UPPER CASE PRIM. LOWER CASE STARTS IN PRIM1.
10600 GO TO 71
10700 70 IF(J5.LE.9)GO TO 71
10800 IF(IFNT)J5=J5+26
10900 71 RX=R6
11000 R6=R5*.28
11100 C .29 IS SIZE FACTOR -- PERHAPS CHANGE SIZE IN FONT TO =1.
11200 RY=R7
11300 R7=R6
11400 RZ=R8
11500 R4=R4+R4X
11600 C SHIFTS DOWN ??? WHY NOT GET RID OF THIS.??
11700 R8=FILL
11800 NRJ=NR
11900 C GETS RIGHT FILE
12000 JA=12
12100 C ANY NON-11 NUMBER .GT.10 WILL DO.
12200 CC R2=J2
12300 CALL CLEFS
12400 R6=RX
12500 R7=RY
12600 R8=RZ
12700 C PUTS BACK RIGHT STUFF
12800 IF(NXZ)GO TO 6
12900 NR=NRX
13000 JFONT=NJF
13100 GO TO 6
13200
13300 30 J7=0
13400 R6=R5
13500 CALL PNUM
13600 C 47=BLANK (WAS 99)
13700 6 J3=ROFF(RB)
13800 R4=RW
13900 11 JY=JY-J5X*JX
14000 C TO GET NEXT NUM OUT OF JY
14100 53 JX=JX/100
14200 50 CONTINUE
14300 55 IF(JTR.EQ.99)GO TO 100
14400 GO TO 52
14500
14600
14700 C FOR TRILLS
14800 C 7, POS1, STF, NT#, SIZE, POS2, X IF X=1 THEN NO WAVEY LINE
14900 20 RF=R6
15000 IF(J7.LE.1)GO TO 200
15100 IF(J7.GE.8)GO TO 201
15200 C JUMP FOR OTTAVA
15300 C NEXT FOR SPECIAL PEDAL MARKS.
15400
15500 C PEDAL: 7,STF,POS,0=STND POS,NNN=PEDS,POS2,BRACK #S,LFT POS BRK.
15600 C P5=101 MEANS LFT & RT PEDS., P7=2 NO BRK, =3 --!, =4 ----
15700 RW=R8
15800 RB=R3
15900 NR=J7
16000 JY=J5
16100 CALL NOZERO(R9)
16200 RY=R9
16300 RX=23.84*R9*RSTJ2
16400 R6=.45*RY
16500 J9=0
16600 J5=18
16700 C IN FILE CLEF1.DMD
16800 JA=3
16900 R5=0
17000 R7=0
17100 R4=R4-6
17200 C STANDARD POS IS AT -6 ****** (I.E. P4=0 PUTS TOP OF IT AT -6)
17300 CALL CLEFS
17400 IF(JY.EQ.0)GO TO 222
17500 R8=-1
17600 J5=19
17700 IF(JY.LT.100)GO TO 203
17800 JY=JY-100
17900 CALL CLEFS
18000 203 R3=RB+RX
18100 IF(JY.LT.10)GO TO 204
18200 JY=JY-10
18300 CALL CLEFS
18400 204 R3=RB+RX+RX
18500 IF(JY.NE.0)CALL CLEFS
18600 C PRINTS THE 3 BOTTOM ITEMS
18700
18800 222 IF(NR.EQ.2)RETURN
18900 IF(RW.NE.0)R3=RB-5.96*RW
19000 C FOR BRACKET
19100 RX=POS
19200 R6=RF
19300 R4=R4+3.
19400 R5=R4
19500 J7=0
19600 R7=0
19700 R8=0
19800 R10=0
19900 206 CALL ITMSUB
20000 IF(NR.EQ.4)RETURN
20100 C R7=4= NO END ON BRKT.
20200 POS=RX
20300 C POS GOT RUINED IN ITMSUB.
20400 R3=ROFF(RHORZ(RF))
20500 R5=R5+1.4*RY
20600 CALL ITMSUB
20700 RETURN
20800
20900 C NEXT FOR 8VA BASSA
21000 202 R7=47717088.
21100 R8=88709999.
21200 RR10=138.
21300 R6=51089170.
21400 GO TO 214
21500 201 CALL NOZERO(R5)
21600 IF(J7.EQ.15)GO TO 205
21700 R6=51089170.
21800 C NEXT = 8VA
21900 RR10=47.
22000 R7=99999999.0
22100 214 RR5=R5*RSTJ2
22200 RR3=R3+RR10*RR5
22300 C SAVE FOR POS. OF DASHES
22400 JTR=-1
22500 J4=J7
22600 J10=J8
22700 C SAVE THESE IN PARAMS NOT USED IN ALPHA
22800 GO TO 212
22900
23000 C 15MA - - - - -
23100 205 R6=51010582.
23200 R7=70999999.
23300 RR10=56.
23400 GO TO 214
23500
23600 C NEXT FOR THE DASHES. J8=1 =NO END BRACK.
23700 213 R8=1.8*RR5
23800 R9=0
23900 R3=RR3
24000 R6=RF
24100 R4=R4+.7*RSTJ2
24200 R5=R4
24300 J5=J4
24400 J11=-1
24500 IF(J4)J11=-J11
24600 IF(J10.NE.0)J11=0
24700 J7=1
24800 J10=0
24900 C GO DRAW THE DASHES
25000 CALL ITMSUB
25100 RETURN
25200
25300 200 CALL NOZERO(R5)
25400 IF(J7.EQ.-8)GO TO 202
25500 RR10=R5
25600 C ↑↑↑↑↑ R10 GETS WIPED OUT IN ALPHA OR CLEFS.
25700 J3=J3+6*RSTJ2
25800 JR3=J3
25900 R6=51898799.0
26000 C @tr LWR CASE, ITAL. TR
26100 R7=99999999.0
26200 R8=R7
26300 JTR=J7
26400 212 R5=.8*R5
26500 GO TO 54
26600 52 IF(JTR.NE.0)GO TO 100
26700 C GO TO 100 IF NO WAVY LINE IS NEEDED
26800 R3=JR3+20.*RSTJ2*RR10
26900 JA=4
27000 J7=-2
27100 C J7 IS SWITCH TO DRAW WIGGLE
27200 R6=RF
27300 R9=.7*RR10
27400 C SETS WIGGLE HEIGHT
27500 R8=.9*RR10
27600 C RR10 IS SIZE (P5)
27700 J10=0
27800 IF(IPLT)J10=1
27900 CALL ITMSUB
28000 C SINGLE WIGGLE ON DPY, DOUBLE ON PLOTTER.
28100 100 IF(JTR)GO TO 213
28200 IF(KFNT)IFNT=1
28300 KFNT=0
28400 END
28500
28600
28700 SUBROUTINE SPACER(J5,IFNT,RB,R)
28800 C SPACES ALPHABET ITEMS.
28900 DATA RS/1.08/,RSPC/1./,RLWR/.96/
29000 C JUMP TO USE PRIMITIVE ALPHABET.
29100 IF(J5.GT.47)GO TO 10
29200 IF(J5.LE.9)GO TO 177
29300 IF(J5.LT.36)GO TO 10
29400 C NEXT FOR NUMBERS, SPACE AND PUNCTUATION.
29500 177 RSX=RSPC
29600 IF(IFNT)RSX=.9
29700 GO TO 3
29800 10 IF(J5.LT.47)GO TO 5
29900 IF(J5.EQ.52)GO TO 14
30000 IF(J5.EQ.48)IFNT=1
30100 IF(J5.EQ.49)IFNT=-1
30200 C ABOVE 2 NO LONGER NEEDED.
30300 IF(J5.GE.55)GO TO 5
30400 C PUNCT. WILL EXPAND ABOVE 54.
30500 RETURN
30600 14 IFNT=0
30700 C #=52=PRIMITIVE
30800 JA=10
30900 RETURN
31000 5 RSX=RS
31100 IF(IFNT)RSX=RLWR
31200 C FOR LOWER CASE SPACING. (96%)
31300 IF(J5.EQ.22)GO TO 277
31400 IF(J5.NE.32)GO TO 3
31500 277 RSX=RSX*1.12
31600 C FOR M AND W
31700 3 IF(J5.GE.36)GO TO 21
31800 IF(J5.EQ.1)GO TO 21
31900 IF(J5.EQ.18)GO TO 21
32000 IF(J5.EQ.19)GO TO 21
32100 C FOR 1,I AND J
32200 IF(IFNT.GE.0)GO TO 4
32300 C NEXT FOR LOWER CASE ONLY.
32400 IF(J5.EQ.15)GO TO 21
32500 IF(J5.EQ.19)GO TO 21
32600 IF(J5.EQ.21)GO TO 21
32700 IF(J5.NE.29)GO TO 4
32800 21 IF(J5.NE.47)RSX=RSX*.68
32900 C FOR F,I,J,L,T
33000 4 RB=RB+R*RSX
33100 END
33200
33300
33400 CC SUBROUTINE JDRAW(M,R3,CENTR,RSTJ2,RX,RY)
33500 CC COMMON/LL/LL
33600 CC DIMENSION M(1)
33700 CC RC=RX*RSTJ2
33800 CC RD=RY*RSTJ2
33900 CC DO 2 K=2,M(1)
34000 CC CALL UNPACK(IA,IB,M(K))
34100 CC2 CALL LINES(FLOAT(IA)*RC+R3,FLOAT(IB)*RD+CENTR,LL)
34200 CC END
34300
34400 CC SUBROUTINE CENTER(CNTR)
34500 C TO CENTER ITEMS CREATED WITH DRAWING PROG.
34600 CC COMMON /STF/RSTFAC(8),RSTJ2
34700 CC COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
34800 CC EQUIVALENCE (R4,RJQ(2))
34900 CC CNTR=POS+(2+AMOD(R4,100.)*7)*RSTJ2
35000 CC END
35100
35200 CC SUBROUTINE LINX(A,B,C,D)
35300 C SAVES SPACE FOR SINGLE LINES.
35400 CC CALL LINES(A,B,3)
35500 CC CALL LINES(C,D,2)
35600 CC END
35700
35800 CC SUBROUTINE UNPACK(M,N,I)
35900 CC COMMON/LL/L
36000 C L IS FOR VIS. OR INVIS. LINES.
36100 CC N=I
36200 CC L=2
36300 CC M=N/100000000
36400 CC IF(M.EQ.0)GO TO 2
36500 CC L=3
36600 C ADJUST BH AND FL FOR HEIGHT OF NOTE AND 'WIDTH'
36700 CF IPOS=ROFF(RJQ(1)*DIS)
36800 CCCF IF(RMINI.LT..9)IPOS=IPOS+1
36900 CF JPOS=ROFF(CENTR*RHT)
37000 CF IF(-RMINI.EQ.PRE)GO TO 10
37100 CF PRE=-RMINI
37200 CCCF D=.25*RMINI
37300 CF D=.25
37400 CF B=BH*RMINI*RHT
37500 CF E=RMINI*DIS
37600 CF A=BL*E
37700 CF IC=A
37800 CF A=A*A
37900 CF E=-B/4.
38000 CF K=B
38100 CF B=B*B
38200 C USES EQUATION FOR ELLIPSE
38300 CF N=1
38400 CF NX=2
38500 CF6 DO 1 J=-K,K
38600 CF Y=J*J
38700 CF X=SQRT(A-(A*Y)/B)
38800 CF L=E-X
38900 CF M=X+E
39000 C THE TWO SIDES OF THE LINE
39100 CF IF(N)CALL EXCH(L,M)
39200 CF IRN(NX)=L
39300 CF IRN(NX+1)=M
39400 C C IS VERTICLE POS.
39500 CF NX=NX+2
39600 CF E=E+D
39700 C E IS TO TILT IT.
39800 CF1 N=-N
39900 CF10 CALL PLOT(IPOS+3,JPOS,3)
40000 CF N=2
40100 C 1ST LOC. OF ARRAY HAS "PRE"
40200 CF L=IPOS+IC
40300 CF DO 11 M=-K,K
40400 CF J=M+JPOS
40500 CF CALL PLOT(L+IRN(N),J,2)
40600 CF CALL PLOT(L+IRN(N+1),J,2)
40700 CF11 N=N+2
40800 CF END
40900
41000 CC SUBROUTINE RJBX(R)
41100 CC COMMON Q(4),R3,RJQ(39)/STF/RSTFAC(8),RSTJ2
41200 CC R3=R3+R*RSTJ2
41300 CC END
41400
41500 CC SUBROUTINE CENTX
41600 CC COMMON A,B,CENTR,D,E,R4,R(38) /STF/RSTFAC(8),RSTJ2
41700 CC 1 /POSI/STFF(8),JJ2,POS
41800 CC CENTR=POS-18.*RSTJ2+AMOD(R4,100.0)*RSTJ2*7.
41900 CC END
42000 C******** THE ABOVE ARE NOW IN SMALL.FAI (3/75)
42100
42200 C****** 7, STF, POS, HGT, NUM OF SHARPS OR FLATS(+ OR -), CLEF
42300 C ( CLEF = TREB,0 BASS,1 ALT,2 TEN,3 )
42400 SUBROUTINE KSIG
42500 C FOR KEY SIGNATURES AND ACCENTS, ETC. (IN 'SCORE')
42600 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(17),T,S,Z/STF/RSTFAC(-3/4),RSTJ2
42700 EQUIVALENCE (R4,RJQ(2)),(J4,JQ(2)),(J5,JQ(3)),(J6,JQ(4))
42800 1,(R6,RJQ(4))
42900
43000 JA=9
43100 C USES THIS KEY NUM IN NOTWRT
43200 C COUNTER
43300 IZ=IABS(J5)
43400 C NUMBER OF CALLS ON NOTWRT
43500 C THE CLEF NUM. IT GETS WIPED OUT IN NOTWRT.
43600 JW=1
43700 R6=0
43800 IF(J5.GT.0)JW=2
43900 C THE CODE FOR FLAT OR SHARP
44000 IF(IZ.LT.100)GO TO 5333
44100 JW=3
44200 IZ=IZ-100
44300 C WILL MAKE NATURALS IF 100 IS ADDED OR SUBTRACTED.
44400 5333 CLEF=-(J6+1)
44500 C CLEF #S ARE CHNGD TO -1,-2,-3,-4 (TREB.,BA.,ALT.,TEN.)
44600 C CLEF NOW SET IN MAIN PROG.
44700 C IF NO CLEF GIVEN, TREBLE IS USED.
44800 T=10.
44900 IF(CLEF.LT.-2.)T=11.
45000 S=CLEF+4.
45100 IF(CLEF.EQ.-4)S=-1.
45200 IF(J5.LT.0)GO TO 253
45300 W=-3.
45400 YY=4.
45500 Z=11.
45600 C SHARPS
45700 GO TO 353
45800 253 W=3.
45900 YY=-4.
46000 Z=7.
46100 C FLATS
46200 353 N=1
46300 Z=Z+R4
46400 RX=JQ(1)
46500 RA=0
46600 C RA IS AMOUNT TO BE ADDED TO ORIGINAL POS.
46700 DO 553 KA=1,IZ
46800 J5=JW
46900 RJQ(1)=RX+RA
47000 RA=RA+13.*RSTJ2
47100 C MOVES OVER FOR NEXT ACCI.
47200 RD=Z
47300 R4=Z
47400 IF(CLEF.NE.-1.)GO TO 7
47500 IF(R4.GT.12.)R4=R4-7.
47600 GO TO 9
47700 7 R4=R4-S
47800 IF(R4.GT.T)R4=R4-7.
47900 C ABOVE ARRANGES VERT. POS OF ACCIS.
48000 9 J4=R4
48100 C FOR VERT. POS. IN 'DRWNT' (WHEN PLOTTING.)
48200 CALL CENTX
48300 CALL NOTWRT
48400 Z=RD+W
48500 IF(N)Z=RD+YY
48600 553 N=-N
48700 END